home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
526-550
/
disk_549
/
fontlist
/
source
/
fontlist.mod
< prev
next >
Wrap
Text File
|
1992-05-06
|
9KB
|
217 lines
(*------------------------------------------------------------------------------
Project : FontList
Module : FontList.mod
Author : Robert Brandner (rb)
Address : Schillerstr. 3 / A-8280 Fürstenfeld / AUSTRIA / EUROPE
Copyright : Public Domain
Language : Modula-II (M2Amiga V4.0d)
History : V0.1 24-Mar 91, rb
History : V0.5 25-Mar 91, rb Ausgabe auf unsichtbare Bitmap
History : V0.6 22-Aug 91, rb Anpassung an V4.0
Contents : Liste aller Fonts in FONTS: mit Schriftprobe ausdrucken.
------------------------------------------------------------------------------*)
(*$ StackChk := FALSE *)
(*$ RangeChk := FALSE *)
(*$ OverflowChk := FALSE *)
(*$ ReturnChk := FALSE *)
(*$ LongAlign := FALSE *) (* make this TRUE for MC680x0, x>1 *)
(*$ Volatile := FALSE *)
(*$ LargeVars := FALSE *)
(*$ StackParms := FALSE *)
MODULE FontList;
FROM DosD IMPORT sharedLock,FileInfoBlock,FileLockPtr,
FileHandlePtr,newFile;
FROM DosL IMPORT Lock,UnLock,Examine,ExNext,Open,Close,Write;
FROM Arts IMPORT Terminate;
FROM SYSTEM IMPORT ADR;
FROM String IMPORT Copy,Concat,Length;
FROM Conversions IMPORT StrToVal;
FROM GraphicsD IMPORT TextAttr,TextFontPtr,normalFont,FontFlags,FontFlagSet,
RastPortPtr,RastPort,ColorMapPtr,BitMap,
ViewModeSet;
FROM GraphicsL IMPORT SetFont,CloseFont,SetRGB4CM,SetRast,Move,Text,SetAPen,
InitRastPort,InitBitMap,AllocRaster,FreeRaster,
GetColorMap;
FROM DiskFontL IMPORT OpenDiskFont;
FROM HardCopy IMPORT DumpRPort;
FROM Printer IMPORT Error,SpecialSet;
FROM Terminal IMPORT WriteString,WriteLn;
CONST TITLE="\[1mFontList V0.6\[0m © '91 Robert Brandner";
TEXT="AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZzÄÖöÜü";
FLAGS=FontFlagSet{romFont,diskFont,proportional,designed};
PRTERROR="Can't open PRT:";
BMERROR="No memory for Bitplane.";
F1ERROR="FONTS: not found.";
F2ERROR="FONTS: assigned to file.";
VAR lock, lock2 : FileLockPtr;
(*$ LongAlign := TRUE *) (* Dos braucht Variablen an Langwortgrenzen! *)
info,info2 : FileInfoBlock;
(*$ POP LongAlign *)
ok, prtok : BOOLEAN;
Path, FName : ARRAY[0..99] OF CHAR;
size, max : LONGINT;
rp : RastPort;
bm : BitMap;
cm : ColorMapPtr;
ta : TextAttr;
font : TextFontPtr;
prterr : Error;
printer : FileHandlePtr;
newline : ARRAY[0..0] OF CHAR;
(*------------------------------------------------------------------------------
String auf Drucker ausgeben. (Drucker wird jedesmal wieder ge-
schlossen, da es sonst zu Kollisionen mit DumpRPort kommt.
------------------------------------------------------------------------------*)
PROCEDURE Print(txt:ARRAY OF CHAR);
VAR act:LONGINT;
BEGIN
printer:=Open(ADR("PRT:"),newFile); (* Printer als File öffnen. *)
IF printer=NIL THEN
WriteString(PRTERROR); WriteLn; (* melden, daß Printer nicht *)
Terminate; (* geöffnet werden konnte. *)
END;
(*$ StackParms := TRUE *)
act:=Write(printer,ADR(txt),Length(txt)); (* Text ausgeben *)
(* POP StackParms *)
WriteString(txt); (* gleichen Text auf Screen *)
Close(printer); printer:=NIL; (* Printer schließen. *)
END Print;
(*--- Anzeigen des Fonts <FName>.font, in Größe <max>. -----------------------*)
PROCEDURE ShowFont;
BEGIN
Concat(FName,".font"); (* Fontnamen ergänzen *)
WITH ta DO (* TextAttr-Struktur füllen *)
name:=ADR(FName); (* Fontname *)
ySize:=max; (* Fonthöhe *)
style:=normalFont; (* normale Schriftart *)
flags:=FLAGS; (* wenn möglich, prop. und designed *)
END;
font:=OpenDiskFont(ADR(ta)); (* Font öffnen *)
IF font#NIL THEN (* erfolgreich geöffnet *)
SetRast(ADR(rp),0); (* Screen löschen *)
SetFont(ADR(rp),font); (* neuen Font verwenden *)
Move(ADR(rp),5,5+rp.txBaseline);
Text(ADR(rp),ADR(TEXT),58); (* Test-Text auf Bitmap ausgeben *)
CloseFont(font); (* Font wieder schließen *)
font:=NIL;
prtok:=DumpRPort(ADR(rp),cm,ViewModeSet{},0,0,960,rp.txHeight+10,
960,rp.txHeight+10,SpecialSet{},prterr);
ELSE
Print("Couldn't open"); (* melden, daß Font nicht geöffnet *)
Print(newline); (* werden konnte. *)
END;
END ShowFont;
(*------------------------------------------------------------------------------
Durchsuchen des FONTS:Fontname Directorys. Einträge sollten Files
sein, und als Namen die Größe haben (8,9,11,...).
------------------------------------------------------------------------------*)
PROCEDURE ScanSizes(Path:ARRAY OF CHAR);
VAR ok,signed,err:BOOLEAN;
BEGIN
signed:=FALSE;
max:=1;
lock2:=Lock(ADR(Path),sharedLock);
IF lock2=NIL THEN RETURN END; (* kann nicht zugreifen. *)
ok:=Examine(lock2,ADR(info2));
REPEAT (* Ganzes Dir. durchsuchen *)
ok:=ExNext(lock2,ADR(info2));
IF ok THEN
IF info2.dirEntryType<0 THEN (* Ein File gefunden. *)
StrToVal(info2.fileName,size, (* in Zahl umwandeln, zum *)
signed,10,err); (* Größenvergleich *)
IF size>max THEN (* max. Größe zu späteren *)
max:=size; (* Öffnen des Fonts merken *)
END;
Print(info2.fileName); (* Alle Fontgrößen *)
Print(", "); (* ausgeben. *)
END;
END;
UNTIL NOT ok;
UnLock(lock2); lock2:=NIL;
Print(newline);
ShowFont; (* Font in Grafik ausgeben *)
END ScanSizes;
(*------------------------------------------------------------------------------
Durchsuchen des FONTS: Directorys. Gefundene Directorys weiter
durchsuchen, sie sollten die versch. Größen enthalten.
------------------------------------------------------------------------------*)
PROCEDURE ScanFonts;
VAR NewPath:ARRAY[0..99] OF CHAR;
BEGIN
REPEAT (* ganzes Dir. durchsuchen *)
ok:=ExNext(lock,ADR(info));
IF ok THEN
IF info.dirEntryType>0 THEN (* ein Directory gefunden. *)
Copy(NewPath,Path); (* Neuen Pfad *)
Concat(NewPath,info.fileName); (* zusammenbauen. *)
Copy(FName,info.fileName); (* Fontnamen merken. *)
Print(newline);
Print("Font : ");
Print(FName); Print(newline);
Print("Sizes : ");
ScanSizes(NewPath); (* Directory durchsuchen. *)
END;
END;
UNTIL NOT ok;
END ScanFonts;
(*------------------------------------------------------------------------------
Öffnen einer unsichtbaren Bitmap, und einrichten eines Rastports,
sowie einer Colormap für diese Bitmap.
------------------------------------------------------------------------------*)
PROCEDURE MakeBitMap;
BEGIN
InitBitMap(bm,1,960,200); (* 960 Pixels Druckerbreite *)
InitRastPort(rp);
rp.bitMap:=ADR(bm); (* Rastport und BMap verbinden. *)
bm.planes[0]:=AllocRaster(960,200); (* Bitplane anfordern. *)
IF bm.planes[0]=NIL THEN
WriteString(BMERROR); WriteLn; (* melden, wenn keine Bitplane *)
Terminate; (* bekommen, und abbrechen. *)
END;
cm:=GetColorMap(2); (* Colormap anfordern *)
SetRGB4CM(cm,0,0FH,0FH,0FH); (* Hintergrund weiß. *)
SetRGB4CM(cm,1,00H,00H,00H); (* Schriftfarbe schwarz. *)
SetAPen(ADR(rp),1);
END MakeBitMap;
BEGIN
WriteString(TITLE); WriteLn;
Path:="FONTS:";
newline[0]:=CHAR(10);
lock:=Lock(ADR(Path),sharedLock);
IF lock=NIL THEN
WriteString(F1ERROR);WriteLn; (* FONTS: nicht da *)
Terminate;
END;
ok:=Examine(lock,ADR(info));
IF info.dirEntryType<0 THEN
WriteString(F2ERROR);WriteLn; (* FONTS: ist auf ein *)
Terminate; (* File assigned. *)
END;
MakeBitMap; (* Bitmap erzeugen. *)
ScanFonts;
WriteString("Ready");WriteLn;
CLOSE
IF lock#NIL THEN UnLock(lock) END;
IF lock2#NIL THEN UnLock(lock2) END;
IF font#NIL THEN CloseFont(font) END;
IF printer#NIL THEN Close(printer) END;
IF bm.planes[0]#NIL THEN FreeRaster(bm.planes[0],960,200) END;
END FontList.